Giga Games 1

home *** CD-ROM | disk | FTP | other *** search

/ Giga Games 1 / Giga Games.iso / net / usenet / volume2 / dating < prev next >

Wrap

Internet Message Format | 1987-10-26 | 50.2 KB

Path: uunet!tektronix!tekgen!tekred!games-request From: games-request@tekred.TEK.COM Newsgroups: comp.sources.games Subject: v02i063: dating - computerized dating data base Message-ID: <1746@tekred.TEK.COM> Date: 26 Oct 87 19:41:23 GMT Sender: billr@tekred.TEK.COM Lines: 2422 Approved: billr@tekred.TEK.COM Submitted by: Thomas M Johnson <john1233%csd4.milw.wisc.edu@csd1.milw.wisc.edu> Comp.sources.games: Volume 2, Issue 63 Archive-name: dating #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of shell archive." # Contents: Makefile Questions README bbase date.doc.v1 date.doc.v2 # date.v1.p date.v2.p getw.c getw.h # Wrapped by billr@tekred on Mon Oct 26 11:38:38 1987 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f Makefile -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"Makefile\" else echo shar: Extracting \"Makefile\" $336 characters$ sed "s/^X//" >Makefile <<'END_OF_Makefile' X# crude makefile for datingame (none supplied with original source) X# Xv1: date.v1.p X pc date.v1.p X mv a.out datingame X touch v1 X Xinstall-v1: v1 X touch database X Xv2: getw.o date.v1.p X pc date.v2.p getw.o X mv a.out datingame X touch v2 X Xinstall-v2: v2 X mkdir .date X cp Questions .date/Questions X cp bbase .date/bbase X touch .date/database END_OF_Makefile if test 336 -ne `wc -c <Makefile`; then echo shar: \"Makefile\" unpacked with wrong size! fi # end of overwriting check fi if test -f Questions -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"Questions\" else echo shar: Extracting \"Questions\" $6299 characters$ sed "s/^X//" >Questions <<'END_OF_Questions' X XWhat is your weight? X A. Under 100 lbs. X B. 100 lbs-125 lbs. X C. 125 lbs-140 lbs. X D. 140 lbs-160 lbs. X E. 160 lbs-180 lbs. X F. 180 lbs-200 lbs. X G. 200 lbs-220 lbs. X H. Over 220 lbs. X Xh XWhat is your height? X A. Under 5 ft. X B. 5 ft-5 ft. 4 in. X C. 5 ft. 4 in. - 5 ft. 7 in. X D. 5 ft. 7 in. - 5 ft. 10 in. X E. 5 ft. 10 in. - 6 ft. X F. Over 6 ft. X Xf XWhat is the color of your hair? X A. Brown X B. Black X C. Red X D. Blond X E. Gray X F. Auburn X G. Bald X Xg XWhat is the color of your eyes? X A. Brown X B. Blue X C. Hazel X D. Green X E. Violet X F. Gray X Xf XHow old are you? X A. Less than 18 X B. 18-20 X C. 21-23 X D. 24-27 X E. 28-32 X F. 33-40 X G. 41-50 X H. Over 50 X Xh XHow do you dress? X A. Preppie X B. Casual X C. Jeans and T-shirt X D. Sleezy X E. Dressy X F. Conservatively X Xf XWhat is your ethnic group? X A. White X B. Black X C. Hispanic X D. Oriental/Asian X E. Indian X Xe XWhat is your status? X A. Single X B. Separated/Divorced X C. Widow/Widower X D. Married X Xd XHow do you rate yourself on a Xscale from 1 to 10? X A. Under 5 X B. 5 to 6 X C. 7 to 8 X D. 9 to 10 X E. Over 10 X Xe XGiven the following choices XWhat is your favorite hobby? X A. Sports K. Camping X B. Dancing L. Computers / Electronics X C. Concerts M. Politics X D. Travel N. Listening to music X E. Theater O. Photography X F. Reading P. Arts and Crafts X G. Domestics Q. Cooking X H. Sex R. Dancing X I. Watching television S. Cars / Mechanics X J. Shopping T. Work / Career X Xt XWhat is your favorite kind of music? X A. Rock K. Opera X B. Pop L. Folk X C. New Wave M. Country and Western X D. Punk N. Gospel X E. Soul O. Electronic X F. Disco P. Movie Sound Tracks X G. Jazz Q. Easy listening X H. Rhythm and Blues R. Rap X I. Classical S. Heavy Metal X J. Classic Rock X Xs XHow would you feel recieving Xan obscene phone call? X A. I would like it. X B. It would be interesting. X C. I would not like it. X Xc XWhich of the following comes closest Xto describing your social life? X A. I hang out with a large crowd. X B. I have a small circle of close friends. X C. I have many acquaintances but not many X truly close friends. X Xc XWhere would you prefer to live? X A. Country X B. City X C. Suburbs X Xc XCurrent education level X A. Did not finish high school X B. High school X C. Some college / Technical training X D. Currently working toward 4 year degree X E. 4 year degree X F. Masters degree X G. Doctorate degree X Xg XI consider myself X A. Shy X B. Outgoing X C. Not shy but not outgoing either X Xc XWhat is your favorite social activity? X A. Going to bars X B. Cruising X C. Concerts/Theater X D. Going to the movies X E. Watching T.V. X F. Partying X G. Dancing X H. Playing BINGO X I. Gab sessions X Xi XAre you emotionally open? X A. I am warm and expressive X B. I can usually express my feelings but sometimes X I hold back X C. I find it hard to express myself X D. I never say what I feel X Xd XWhat is most important to you in a person? X A. Kindness and understanding X B. Assurance and decisiveness X C. Money and power X D. Education and intelligence X E. Honesty and openness and trust X F. Looks and build X Xf XHow important is sex to you? X A. I can take it or leave it X B. Sex is a natural part of a relationship X C. Sex is a requirement in relationships X D. I have never had sex X Xd XHow important is it to love your sex partner? X A. Love is very important X B. Love is semi-important X C. Love is not important X D. Love and sex? I never confuse the two X Xd XWhy are you using the Date-A-Base? X A. To find new friends X B. To find a steady lover X C. To find a one night stand X D. Just looking X Xd XI would rather watch a movie X A. In the theater X B. On Television X C. In a 25 cent booth with a stack of quarters X Xc XIf you are truly in love X A. Both should be faithful X B. Fooling around with others is alright X C. I pleed the 5th ammenddment X Xc XHow ambitious are you? X A. Very ambitious X B. Moderately ambitious X C. Laid back X D. Very lazy X Xd XDo you smoke? X A. Do not smoke X B. Light cigarette smoker X C. Heavy cigarette smoker X Xc XWith regards to the telephone.. X A. I enjoy talking on the phone X B. I hate the phone X C. I use the phone only when necessary X Xc XWhat kind of television do you watch? X A. Sitcoms X B. Soaps X C. Variety X D. Movies X E. Sports X F. News X G. Public TV X H. Do not watch TV X Xh XWhich goal is most important to you? X A. Wealth X B. Knowledge X C. Serenity X D. Power X E. Popularity X F. Respectability X Xf XWhat kind of books do you like to read? X A. Science fiction X B. Classics X C. Non-fiction / Technical X D. Mysteries X E. Poetry X F. Novels X G. Romance X Xg XWhen are usually the most alert? X A. Morning X B. Afternoon X C. Early evening X D. Late evening X Xd XHow would you describe your upbringing? X A. Strict X B. Average X C. Permissive X D. Indifferent X Xd XHow often do you usually date? X A. Almost every night X B. Once a week X C. A few times a week X D. A few times a month X E. Irregularly X F. Never X Xf XWhat would your ideal relationship be? X A. Exciting X B. Platonic X C. Varied X D. Casual X E. Physical X F. Exclusive X G. Intense X H. Sensible X I. Intimate X J. Long-lived X K. Undemanding X L. Considerate X M. Romantic X Xm XWhat sort of people are you most comfotable with? X A. Outdoors types X B. Artists X C. Average folks X D. Intellectuals X E. Working people X F. Professionals X G. Cultured individuals X Xg XWho do you live with? X A. Alone X B. With roomate X C. With lover X D. With parents X E. With spouse X Xe XHonestly - how is your body? X A. I am in top shape X B. I am in shape X C. I go to the gym occasionally X D. Do not ask me about my body X Xd XI consider myself... X A. A real knockout - guaranteed X B. Very good looking X C. I am pretty cute X D. Average / Not bad X E. I make up for it in other ways X Xe XWould you be interested in meeting your match? X A. Yes X B. No X C. Only if I am contacted first X Xc X END_OF_Questions if test 6299 -ne `wc -c <Questions`; then echo shar: \"Questions\" unpacked with wrong size! fi # end of overwriting check fi if test -f README -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"README\" else echo shar: Extracting \"README\" $486 characters$ sed "s/^X//" >README <<'END_OF_README' XWell, here is a computer dating service I have just finished. XIf features a 40 question questionaire and matches people up by Xpercentage with MOTOS. There are 2 versions available. X XVersion 1.0: requires only a Pascal Compiler X XVersion 2.0: designed to run under unix 4.3 bsd. It has all the options X of version 1 plus more. It may run under other versions X of unix, if your system supports the features it requires. X X X Tom X john1233@csd4.milw.wisc.edu END_OF_README if test 486 -ne `wc -c <README`; then echo shar: \"README\" unpacked with wrong size! fi # end of overwriting check fi if test -f bbase -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"bbase\" else echo shar: Extracting \"bbase\" $3800 characters$ sed "s/^X//" >bbase <<'END_OF_bbase' Xweight: Xh XUnder 100 lbs. X100 lbs-125 lbs. X125 lbs-140 lbs. X140 lbs-160 lbs. X160 lbs-180 lbs. X180 lbs-200 lbs. X200 lbs-220 lbs. XOver 220 lbs. Xheight: Xf XUnder 5 ft. X5 ft-5 ft. 4 in. X5 ft. 4 in. - 5 ft. 7 in. X5 ft. 7 in. - 5 ft. 10 in. X5 ft. 10 in. - 6 ft. XOver 6 ft. Xhair: Xg XBrown XBlack XRed XBlond XGray XAuburn XBald Xeyes: Xf XBrown XBlue XHazel XGreen XViolet XGray Xage: Xh XLess than 18 X18-20 X21-23 X24-27 X28-32 X33-40 X41-50 XOver 50 Xdress: Xf XPreppie XCasual XJeans and T-shirt XSleezy XDressy XConservatively Xethnic: Xe XWhite XBlack XHispanic XOriental/Asian XIndian Xstatus: Xd XSingle XSeparated/Divorced XWidow/Widower XMarried Xrate: Xe XUnder 5 X5 to 6 X7 to 8 X9 to 10 XOver 10 Xhobby: Xt XSports XDancing XConcerts XTravel XTheater XReading XDomestics XSex XWatching television XShopping XCamping XComputers / Electronics XPolitics XListening to music XPhotography XArts and Crafts XCooking XDancing XCars / Mechanics XWork / Career Xmusic: Xs XRock XPop XNew Wave XPunk XSoul XDisco XJazz XRhythm and Blues XClassical XOpera XFolk XCountry and Western XGospel XElectronic XMovie Sound Tracks XEasy listening XRap XHeavy Metal XClassic Rock Xobscene phone call: Xc XI would like it. XIt would be interesting. XI would not like it. Xfriends: Xc XI hang out with a large crowd. XI have a small circle of close friends. Xmany acquaintances not close friends. Xlive: Xc XCountry XCity XSuburbs Xeducation: Xg XDid not finish high school XHigh school XSome college / Technical training XCurrently working toward 4 year degree X4 year degree XMasters degree XDoctorate degree Xshy: Xc XShy XOutgoing XNot shy but not outgoing either Xsocial life: Xi XGoing to bars XCruising XConcerts/Theater XGoing to the movies XWatching T.V. XPartying XDancing XPlaying BINGO XGab sessions Xopeness: Xd XI am warm and expressive XUsually express, sometimes hold back XI find it hard to express myself XI never say what I feel Ximportant in a person: Xf XKindness and understanding XAssurance and decisiveness XMoney and power XEducation and intelligence XHonesty and openness and trust XLooks and build Xsex: Xd XI can take it or leave it XSex is a natural part of a relationship XSex is a requirement in relationships XI have never had sex Xlove sex partner: Xd XLove is very important XLove is semi-important XLove is not important XLove and sex? I never confuse the two Xwhy here: Xd XTo find new friends XTo find a steady lover XTo find a one night stand XJust looking Xmovie: Xc XIn the theater XOn Television XIn a 25 cent booth with a stack of quarters Xtruly in love: Xc XBoth should be faithful XFooling around with others is alright XI pleed the 5th ammenddment Xambition: Xd XVery ambitious XModerately ambitious XLaid back XVery lazy Xsmoke: Xc XDo not smoke XLight smoker XHeavy smoker Xtelephone: Xc XI enjoy talking on the phone XI hate the phone XI use the phone only when necessary Xtelevision: Xh XSitcoms XSoaps XVariety XMovies XSports XNews XPublic TV XDo not watch TV Xgoal: Xf XWealth XKnowledge XSerenity XPower XPopularity XRespectability Xbooks: Xg XScience fiction XClassics XNon-fiction / Technical XMysteries XPoetry XNovels XRomance Xalert: Xd XMorning XAfternoon XEarly evening XLate evening Xupbringing: Xd XStrict XAverage XPermissive XIndifferent Xdate: Xf XAlmost every night XOnce a week XA few times a week XA few times a month XIrregularly XNever Xideal relationship: Xm XExciting XPlatonic XVaried XCasual XPhysical XExclusive XIntense XSensible XIntimate XLong-lived XUndemanding XConsiderate XRomantic Xpeople comfortable with: Xg XOutdoors types XArtists XAverage folks XIntellectuals XWorking people XProfessionals XCultured individuals Xlive with: Xe XAlone XWith roommate XWith lover XWith parents XWith spouse Xbody: Xd XI am in top shape XI am in shape XI go the gym occasionally XDo not ask me about my body Xconsider myself: Xe XA real knockout - guaranteed XVery good looking XPretty cute XAverage / not bad XMake up for it in other ways Xmeeting match: Xc XYes XNo XOnly if I am contacted first X END_OF_bbase if test 3800 -ne `wc -c <bbase`; then echo shar: \"bbase\" unpacked with wrong size! fi # end of overwriting check fi if test -f date.doc.v1 -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"date.doc.v1\" else echo shar: Extracting \"date.doc.v1\" $2026 characters$ sed "s/^X//" >date.doc.v1 <<'END_OF_date.doc.v1' X Docs for Date-A-Base version 1 X XFirst you must have the following files in your directory called: X bbase X Questions X Xthen you must also issue: X touch database X XThe actual program file is X date.v1.p X XTo run the programs you must X Xpc date.v1.p X Xyou can then ReMove date.v1.p Xand rename the a.out file. X Xso here are the commands: X touch database X pc date.v1.p X mv a.out datingame X XJust type 'datingame' and away it goes. X XThere is a copyright on the program. This doesn't mean you can't give it Xaway or modify it. It only means that my name is to appear in the 'bye' Xprocedure and the commented header. X XTechnical stuff X--------------- X XVersion 1.0 of the Date-A-Base is designed to be 100% standard Pascal. XThis is so it can be run on any machine with a Pascal compiler. X XVersion 2.0 is available with extra options. 2 of these options will Xprobably work on most machines but they were left out on purpose. X XFirst, the use of the wallclock function. Wallclock returns the number Xof seconds since Jan. 1, 1970. I have left references to the wallclock in X(* comments *). If you computer has a wallclock or functionally similar Xfunction, just erase the (* comments *) and if needed, rename the function. X XAlso, you can change the reset() and rewrite() functions to point to Xdifferent directories. Version 2.0 uses a .date directory to Xhold the database, bbase and Questions files. XTo to this you must: X mkdir .date X cp Questions .date/Questions X cp bbase .date/bbase X touch .date/database X Xyou must also change all the reset() and rewite() functions. XEx. reset(database, '.date/database'); X XThe actual name of the file must be in single quotes. X XThe wallclock and reset(pathname) rewrite(pathname) are no available Xto all versions of Pascal. Check before you try them. X X X Thomas M. Johnson X X john1233@csd4.milw.wisc.edu X or X tommyj@lakesys END_OF_date.doc.v1 if test 2026 -ne `wc -c <date.doc.v1`; then echo shar: \"date.doc.v1\" unpacked with wrong size! fi # end of overwriting check fi if test -f date.doc.v2 -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"date.doc.v2\" else echo shar: Extracting \"date.doc.v2\" $1566 characters$ sed "s/^X//" >date.doc.v2 <<'END_OF_date.doc.v2' X Docs for Date-A-Base version 2 X XFirst you must copy the following files into a directory called: X .date X XThe files are: bbase X Questions X Xthen into this directory you must also issue: X touch database X XThe actual program files are X date.v2.p X getw.c X getw.h X XTo run the programs you must X Xcc -c getw.c X XThen: X Xpc date.v2.p getw.o X Xyou can then ReMove date.v2.p, getw.c, getw.o, date.o and getw.h Xand rename the a.out file. X Xso here are the commands: X mkdir .date X cp Questions .date/Questions X cp bbase .date/bbase X touch .date/database X cc -c getw.c X pc date.v2.p getw.o X mv a.out datingame X XJust type 'datingame' and away it goes. X XThere is a copyright on the program. This doesn't mean you can't give it Xaway or modify it. It only means that my name is to appear in the 'bye' Xprocedure and the commented header. X XTechnical stuff X--------------- X XThe differences between version 1.0 and 2.0 are: X XIn 2.0, the user no longer has to enter his own name. His login name Xis automatically placed in the Date-A-Base. X XVersion 2.0 also support the wallclock function. The wallclock function Xreturns the number of seconds that have passed since Jan. 1, 1970. XThis may be called something else on your system, so you can modify the Xsource to any function that is functionally the same. X XIn version 2.0 the data files (database, bbase and Questions) are places Xin a hidden directory (.date). These can be moved to any directory as Xlong as you change the 'reset' commands. X X Thomas M. Johnson X END_OF_date.doc.v2 if test 1566 -ne `wc -c <date.doc.v2`; then echo shar: \"date.doc.v2\" unpacked with wrong size! fi # end of overwriting check fi if test -f date.v1.p -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"date.v1.p\" else echo shar: Extracting \"date.v1.p\" $14598 characters$ sed "s/^X//" >date.v1.p <<'END_OF_date.v1.p' Xprogram date(input, output, Questions, database, bbase); X X(* X Date-A-Base version 1.0 X by X Thomas M. Johnson X X john1233@csd4.milw.wisc.edu X or X tommyj@lakesys X X files used: X Questions - holds the questionaire X database - all people registered with the Date-A-Base X and their information X bbase - data used by brouse command. X X(c) 1987 Thomas M. Johnson *) X X X X Xconst X NUMOFQUESTIONS = 49; X STRINGLENGTH = 20; X ONE = 1; X LOW = 'a'; X Xtype X string = packed array [ONE..STRINGLENGTH] of char; X answerarray = packed array [ONE..NUMOFQUESTIONS] of char; X userp = ^ usertype; X usertype = X record X login: string; X passwd: string; X sex: char; X timeson: integer; X answers: answerarray; X(* laston: integer; *) X next: userp X end; X Xvar X Questions: text; X database: file of usertype; X head: userp; X static: usertype; X bbase: text; X continue: boolean; X X X X function cstrings(var string1: answerarray; string2: answerarray): real; X X (* The function cstrings takes 2 strings and compares them. X cstrings then returns the percent identical the strings are. X The strings are compared letter for letter and must be in the X same place in the string. *) X X X var X counter: integer; X percent: integer; X X begin X percent := 0; X X for counter := ONE to NUMOFQUESTIONS do X if string1[counter] = string2[counter] then X percent := percent + 1; X cstrings := percent / NUMOFQUESTIONS * 100 X end; { cstrings } X X function yesNo: boolean; X X const X yes = 'y'; X no = 'n'; X X var X ch: char; X X begin X repeat X write(output, ' (y/n) '); X readln(input, ch) X until (ch = yes) or (ch = no); X yesNo := ch = yes X X end; { yesNo } X X X X function getanswer(ubound: char): char; X X (* The function getanswer reads in a character and checks to see X if it is in the range of lobound to ubound. If it isn't, then the X user is reprompted. *) X X X var X tempchar: char; X charindex: char; X X begin X repeat X writeln(output); X X for charindex := LOW to ubound do X write(output, charindex); X X writeln(output); X write(output, 'Your choice: '); X readln(input, tempchar) X until (tempchar >= LOW) and (tempchar <= ubound); X X writeln(output); X getanswer := tempchar X end; { getanswer } X X X procedure readstring(var tempstring: string); X X (* read a string from standard input. the string must have X a length of 2 or greater or it is invalid. *) X X X const X init = 0; X inc = 1; X blank = ' '; X X var X ch: char; X length: integer; X X begin X repeat X tempstring := blank; X length := init; X while not eoln(input) do begin X read(input, ch); X length := length + inc; X tempstring[length] := ch X end; X readln(input) X until length > 1 X X end; { readstring } X X procedure readint(var sum: integer); X X (* read in a string from standard input and convert to an X integer. *) X X X const X init = 0; X inc = 1; X base = 10; X intlow = '0'; X inthigh = '9'; X X var X i: integer; X done: boolean; X hold: string; X X begin X i := inc; X done := false; X sum := init; X readstring(hold); X while (i <= STRINGLENGTH) and not done do X if (hold[i] < intlow) or (hold[i] > inthigh) then X done := true X else begin X sum := sum * base + (ord(hold[i]) - ord(intlow)); X if sum > maxint then X done := true X else X i := i + inc X end X end; { readint } X X X X procedure printques(var quests: answerarray); X X (* prints the questions from the file Questions. X the question file is set up like: X X The question X the answers X . X . X . X . X ^G (up limit) X X then ^G is just a marker to signify where the answers end. X low limit is usually and 'a' X up limit the the last answer X X *) X X var X ch: char; X uplimit: char; X chset: set of char; X i: integer; X X begin X reset(Questions); X i := 1; X chset := ['A'..'Z', 'a'..'z', '0'..'9', '?', '.', ' ', '-', '/']; X ch := ' '; X while not eof(Questions) do begin X while not eoln(Questions) do begin X read(Questions, ch); X if ch in chset then X write(output, ch) X else begin X readln(Questions, uplimit); X quests[i] := getanswer(uplimit); X i := i + 1 X end X end; X readln(Questions); X writeln(output) X end X end; { printques } X X function Search(lookfor: string; var hisrec: usertype): boolean; X X (* scan the linked list to find a match between the string lookfor X and the .login field. If there is a match, a true is returned with X the record of that person. Otherwise a false is returned *) X X X var X found: boolean; X temptr: userp; X X begin X found := false; X temptr := head; X X while (temptr <> nil) and not found do X if temptr^.login = lookfor then begin X hisrec := temptr^; X found := true X end else X temptr := temptr^.next; X X Search := found X end; { Search } X X X procedure newUser; X X (* if the person in not in the linked list, add him *) X X X const X male = 'm'; X female = 'f'; X inc = 1; X X var X ch: char; X node: userp; X X X X begin X writeln(output, 'To use the Date-A-Base you will have to answer a'); X writeln(output, 'personal questionaire. Your answers to all the'); X writeln(output, 'questions will available for anyone registered'); X writeln(output, 'in the Date-A-Base to look at.'); X writeln(output); X writeln(output, 'Do you want to continue? '); X continue := yesNo; X if continue then begin X repeat X writeln(output); X writeln(output, 'What sex are you? m or f'); X readln(input, ch) X until (ch = male) or (ch = female); X static.sex := ch; X with static do begin X timeson := inc X end; X X(* laston := wallclock *) X printques(static.answers); X writeln(output); X writeln(output, 'What password do you want to use?'); X writeln(output, 'IMPORTANT: Make this different than'); X writeln(output, 'your login password.'); X readstring(static.passwd); X new(node); X node^ := static; X node^.next := head; X head := node X end X end; { newUser } X X X X X procedure oldUser; X X (* the person is already registered. Just get his data. *) X X X const X X X inc = 1; X var X password: string; X temptr: userp; X found: boolean; X X X begin X repeat X writeln(output); X writeln(output, 'What is your password?'); X write(output, '? '); X readstring(password); X if password <> static.passwd then X writeln(output, 'Sorry, thats not right!') X until password = static.passwd; X with static do begin X timeson := timeson + inc X end; X X(* laston := wallclock *) X temptr := head; X found := false; X while (temptr <> nil) and not found do X if temptr^.login = static.login then begin X static.next := temptr^.next; X temptr^ := static; X found := true X end else X temptr := temptr^.next X X end; { oldUser } X X X X procedure initialize; X X (* This procedure reads in the current file with all registered X users into a linked list. *) X X X var X node: userp; X name: string; X X begin X head := nil; X reset(database); X while not eof(database) do begin X new(node); X read(database, node^); X node^.next := head; X head := node X end; (* while *) X writeln(output); X writeln(output); X writeln(output, ' The'); X writeln(output, ' Date-A-Base'); X writeln(output); X writeln(output); X writeln(output, ' The computerized dating service.'); X writeln(output); X writeln(output); X writeln(output); X writeln(output, 'What is your login name?'); X write(output, '? '); X continue := true; X readstring(name); X static.login := name; X if not Search(name, static) then X newUser X else X oldUser X X X end; { initialize } X X procedure savedata; X X (* save the linked list in the file database *) X X X var X pointer: userp; X X X begin X rewrite(database); X pointer := head; X if pointer <> nil then X while pointer^.next <> nil do begin X write(database, pointer^); X pointer := pointer^.next X end; X write(database, pointer^) X X end; { savedata } X X procedure answer; X X (* answer the questionaire again *) X X X var X check: boolean; X temptr: userp; X found: boolean; X X begin X writeln(output); X writeln(output, 'Are you sure you want to answer all the'); X writeln(output, 'questions again?'); X check := yesNo; X if check then X printques(static.answers); X temptr := head; X found := false; X while (temptr <> nil) and not found do X if temptr^.login = static.login then begin X static.next := temptr^.next; X temptr^ := static; X found := true X end else X temptr := temptr^.next X X end; { answer } X X procedure brouse; X X (* give a quick scan of someone else's questionaire. the data for X the brouse is in bbase. Data looks like: X X the topic X the maximum answer X answer X . X . X . X X *) X X X const X(* clicks = 86400; *) X (* number of seconds in a day *) X low = 'a'; X field = 3; X zero = 0; X marker = 15; X X var X who: string; X index: char; X ch: char; X max: char; X i: integer; X j: integer; X(* time: integer; *) X rec: usertype; X X begin X writeln(output, 'Whose questionare do you want to brouse?'); X write(output, '? '); X readstring(who); X if Search(who, rec) then begin X X i := ONE; X j := ONE; X reset(bbase); X writeln(output); X write(output, 'Name: '); X writeln(output, rec.login); X write(output, 'Used the Date-A-Base '); X write(output, rec.timeson: field); X if rec.timeson = ONE then X writeln(output, ' time. ') X else X writeln(output, ' times. '); X X write(output, 'Last used the Date-A-Base: '); X (* time := wallclock - rec.laston; X time := time div clicks; X if time = zero then X writeln(output, 'today.'); X if time = ONE then X writeln(output, 'yesterday.'); X if time > ONE then begin X write(output, time: field); X writeln(output, ' days ago.') X end; *) X X writeln(output); X while not eof(bbase) do begin X while not eoln(bbase) do begin X read(bbase, ch); X write(output, ch) X end; X readln(bbase); X readln(bbase, max); X for index := low to max do begin X if index = rec.answers[i] then begin X while not eoln(bbase) do begin X read(bbase, ch); X write(output, ch) X end; X writeln(output); X readln(bbase) X end else X readln(bbase) X end; X if j = marker then begin X repeat X writeln(output); X writeln(output, 'Continue? ') X until yesNo; X j := zero; X writeln(output) X end; X j := j + ONE; X i := i + ONE X end X end else X writeln(output, 'Sorry that person is not registered!'); X X repeat X writeln(output); X writeln(output, 'Return to the menu? ') X until yesNo X end; { brouse } X X procedure delete; X X (* delete a person from the linked list *) X X var X found: boolean; X pointer: userp; X X begin X found := false; X writeln(output, 'Are you sure you want to delete yourself?'); X if yesNo then begin X pointer := head; X if pointer^.login = static.login then begin X head := pointer^.next; X dispose(pointer) X end else X while not found do X while pointer^.next <> nil do X if pointer^.next^.login = static.login then begin X pointer^.next := pointer^.next^.next; X dispose(pointer^.next); X found := true X end else X pointer := pointer^.next X end X end; { delete } X X X X X X procedure match; X X (* find a match between 2 people. scans the whole linked list X and reports all matches greater than the amount entered. *) X X X const X loginfield = 47; X perfield = 5; X dplaces = 1; X namefield = 33; X low = 9; X high = 100; X X X var X pointer: userp; X percent: integer; X per: real; X found: boolean; X X X begin X pointer := head; X writeln(output); X writeln(output, 'What is the lowest percent match that'); X writeln(output, 'you want to see? '); X repeat X write(output, ' (10 - 99) '); X X readint(percent) X until (percent > low) and (percent < high); X X X writeln(output); X write(output, '%': perfield); X writeln(output, 'name': namefield); X writeln(output, '----------------------------------------------------'); X X found := false; X if pointer <> nil then X while pointer <> nil do begin X per := cstrings(static.answers, pointer^.answers); X if (per >= percent) and (static.sex <> pointer^.sex) then begin X found := true; X writeln(output); X write(output, per: perfield: dplaces); X write(output, '%'); X writeln(output, pointer^.login: loginfield) X end; X pointer := pointer^.next X end; X if not found then begin X writeln(output); X writeln(output, 'Sorry, no matches found today. Try again later.') X end; X repeat X writeln(output); X writeln(output); X writeln(output, 'Are you ready to continue?') X until yesNo X X end; { match } X X X procedure bye; X X begin X writeln(output); X writeln(output, 'Thank you for using the Date-A-Base'); X writeln(output, 'Hope to hear from you again soon.'); X writeln(output); X writeln(output); X writeln(output); X writeln(output); X writeln(output); X writeln(output,'(c) 1987 Thomas M. Johnson'); X writeln(output) X end; { bye } X X X procedure menu; X X (* The procedure menu is the programs main menu. It prints the X commands and executes the proper subroutine based on the users X choice. *) X X X const X X lastchoice = 'e'; X var X choice: char; X X begin X repeat X writeln(output); X writeln(output); X writeln(output, ' Menu'); X writeln(output, ' ----'); X writeln(output); X writeln(output, ' [a] answer questionare'); X writeln(output, ' [b] brouse questionare'); X writeln(output, ' [c] make a match'); X writeln(output, ' [d] delete your questionare'); X writeln(output); X writeln(output, ' [e] quit'); X X choice := getanswer(lastchoice); X X case choice of X 'a': X answer; X 'b': X brouse; X 'c': X match; X 'd': X delete; X 'e': X writeln(output) X end X until choice = lastchoice X X end; { menu } X Xbegin X initialize; X if continue then begin X menu; X savedata X end; X bye Xend. { date } X END_OF_date.v1.p if test 14598 -ne `wc -c <date.v1.p`; then echo shar: \"date.v1.p\" unpacked with wrong size! fi # end of overwriting check fi if test -f date.v2.p -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"date.v2.p\" else echo shar: Extracting \"date.v2.p\" $15266 characters$ sed "s/^X//" >date.v2.p <<'END_OF_date.v2.p' Xprogram date(input, output, Questions, database, bbase); X X(* X Date-A-Base version 2.0 X by X Thomas M. Johnson X X john1233@csd4.milw.wisc.edu X or X tommyj@lakesys X X file used: X .date/Questions - holds the questionaire X .date/database - all the people registered with the Date-A-Base X and their information X .date/bbase - data used by the brouse command. X X version 2.0 must have getw.h in the same directory. This routine X allows Pascal to access the C getlogin() function. X X X(c) 1987 Thomas M. Johnson *) X X X X Xconst X NUMOFQUESTIONS = 49; X STRINGLENGTH = 20; X ONE = 1; X LOW = 'a'; X Xtype X string = packed array [ONE..STRINGLENGTH] of char; X answerarray = packed array [ONE..NUMOFQUESTIONS] of char; X userp = ^ usertype; X usertype = X record X login: string; X sex: char; X timeson: integer; X answers: answerarray; X laston: integer; X next: userp X end; X Xvar X Questions: text; X database: file of usertype; X head: userp; X static: usertype; X bbase: text; X continue: boolean; X X#include "getw.h" X X function cstrings(var string1: answerarray; string2: answerarray): real; X X (* The function cstrings takes 2 strings and compares them. X cstrings then returns the percent identical the strings are. X The strings are compared letter for letter and must be in the X same place in the string. *) X X X var X counter: integer; X percent: integer; X X begin X percent := 0; X X for counter := ONE to NUMOFQUESTIONS do X if string1[counter] = string2[counter] then X percent := percent + 1; X cstrings := percent / NUMOFQUESTIONS * 100 X end; { cstrings } X X function yesNo: boolean; X X const X yes = 'y'; X no = 'n'; X X var X ch: char; X X begin X repeat X write(output, ' (y/n) '); X readln(input, ch) X until (ch = yes) or (ch = no); X yesNo := ch = yes X end; { yesNo } X X X X X function getanswer(ubound: char): char; X X (* The function getanswer reads in a character and checks to see X if it is in the range of lobound to ubound. If it isn't, then the X user is reprompted. *) X X X var X tempchar: char; X charindex: char; X X begin X repeat X writeln(output); X X for charindex := LOW to ubound do X write(output, charindex); X X writeln(output); X write(output, 'Your choice: '); X readln(input, tempchar) X until (tempchar >= LOW) and (tempchar <= ubound); X X writeln(output); X getanswer := tempchar X end; { getanswer } X X procedure clearstring(var tempstring: string); X X const X X blank = ' '; X var X i: integer; X X begin X for i := ONE to STRINGLENGTH do X tempstring[i] := blank X end; { clearstring } X X X X procedure readstring(var tempstring: string); X X (* read a string from standard input. the string must have X a length of 2 or greater or it is invalid. *) X X X const X init = 0; X inc = 1; X X var X ch: char; X length: integer; X X begin X repeat X clearstring(tempstring); X length := init; X while not eoln(input) do begin X read(input, ch); X length := length + inc; X tempstring[length] := ch X end; X readln(input) X until length > 1 X X end; { readstring } X X procedure readint(var sum: integer); X X (* read in a string from standard input and convert to an X integer. *) X X X const X init = 0; X inc = 1; X base = 10; X intlow = '0'; X inthigh = '9'; X X var X i: integer; X done: boolean; X hold: string; X X begin X i := inc; X done := false; X sum := init; X readstring(hold); X while (i <= STRINGLENGTH) and not done do X if (hold[i] < intlow) or (hold[i] > inthigh) then X done := true X else begin X sum := sum * base + (ord(hold[i]) - ord(intlow)); X if sum > maxint then X done := true X else X i := i + inc X end X end; { readint } X X X X procedure printques(var quests: answerarray); X X (* prints the questions from the file Questions. X the question file is set up like: X X The question X the answers X . X . X . X . X ^G (up limit) X X then ^G is just a marker to signify where the answers end. X low limit is usually and 'a' X up limit the the last answer X X *) X X var X ch: char; X uplimit: char; X chset: set of char; X i: integer; X X begin X reset(Questions,'.date/Questions'); X i := 1; X chset := ['A'..'Z', 'a'..'z', '0'..'9', '?', '.', ' ', '-', '/']; X ch := ' '; X while not eof(Questions) do begin X while not eoln(Questions) do begin X read(Questions, ch); X if ch in chset then X write(output, ch) X else begin X readln(Questions, uplimit); X quests[i] := getanswer(uplimit); X i := i + 1 X end X end; X readln(Questions); X writeln(output) X end X end; { printques } X X X function test(string1: string; string2: string): boolean; X X (* I was having a lot of trouble converting the Search function from X version 1 to this version because the strings were coming out X of the getw.h external procedure 1 character longer than all the X other strings. So the comparison was always false. This function X takes the place of that comparison. X *) X X var X same: boolean; X i: integer; X chset: set of char; X X X begin X i := ONE; X same := true; X chset := ['a'..'z', 'A'..'Z', '0'..'9']; X X while (string1[i] in chset) and (string2[i] in chset) and same do begin X same := string1[i] = string2[i]; X i := i + ONE X end; X X test := same; X if string1[i + ONE] <> string2[i + ONE] then X test := false X end; { test } X X X X X function Search(lookfor: string; var hisrec: usertype): boolean; X X (* scan the linked list to find a match between the string lookfor X and the .login field. If there is a match, a true is returned with X the record of that person. Otherwise a false is returned *) X X X var X found: boolean; X temptr: userp; X X begin X found := false; X temptr := head; X X while (temptr <> nil) and not found do X if test(temptr^.login, lookfor) then begin X hisrec := temptr^; X found := true X end else X temptr := temptr^.next; X X Search := found X end; { Search } X X X procedure newUser; X X (* if the person in not in the linked list, add him *) X X X const X male = 'm'; X female = 'f'; X inc = 1; X X var X ch: char; X node: userp; X X X X begin X writeln(output, 'To use the Date-A-Base you will have to answer a'); X writeln(output, 'personal questionaire. Your answers to all the'); X writeln(output, 'questions will be available for anyone registered'); X writeln(output, 'in the Date-A-Base to look at.'); X writeln(output); X writeln(output, 'Do you want to continue? '); X continue := yesNo; X X if continue then begin X repeat X writeln(output); X writeln(output, 'What sex are you? m or f'); X readln(input, ch) X until (ch = male) or (ch = female); X static.sex := ch; X with static do begin X timeson := inc; X laston := wallclock X end; X printques(static.answers); X writeln(output); X new(node); X node^ := static; X node^.next := head; X head := node X end X end; { newUser } X X X X X procedure oldUser; X X (* the person is already registered. Just get his data. *) X X X const X X X inc = 1; X var X temptr: userp; X found: boolean; X X X begin X writeln(output); X with static do begin X timeson := timeson + inc; X laston := wallclock X end; X temptr := head; X found := false; X while (temptr <> nil) and not found do X if temptr^.login = static.login then begin X static.next := temptr^.next; X temptr^ := static; X found := true X end else X temptr := temptr^.next X X end; { oldUser } X X procedure initialize; X X (* This procedure reads in the current file with all registered X users into a linked list. *) X X X const X X copymax = 15; X var X node: userp; X name: string; X i: integer; X X begin X head := nil; X reset(database,'.date/database'); X while not eof(database) do begin X new(node); X read(database, node^); X node^.next := head; X head := node X end; X writeln(output); X writeln(output); X writeln(output, ' The'); X writeln(output, ' Date-A-Base'); X writeln(output); X writeln(output); X writeln(output, ' The computerized dating service.'); X writeln(output); X writeln(output); X writeln(output); X continue := true; X clearstring(name); X getwh(name); X for i := ONE to copymax do X static.login[i] := name[i]; X if not Search(name, static) then X newUser X else X oldUser X X X end; { initialize } X X procedure savedata; X X (* save the linked list in the file database *) X X X var X pointer: userp; X X X begin X rewrite(database,'.date/database'); X pointer := head; X if pointer <> nil then X while pointer^.next <> nil do begin X write(database, pointer^); X pointer := pointer^.next X end; X write(database, pointer^) X X end; { savedata } X X procedure answer; X X (* answer the questionaire again *) X X X var X check: boolean; X temptr: userp; X found: boolean; X X begin X writeln(output); X writeln(output, 'Are you sure you want to answer all the'); X writeln(output, 'questions again?'); X check := yesNo; X if check then X printques(static.answers); X temptr := head; X found := false; X while (temptr <> nil) and not found do X if temptr^.login = static.login then begin X static.next := temptr^.next; X temptr^ := static; X found := true X end else X temptr := temptr^.next X X end; { answer } X X procedure brouse; X X (* give a quick scan of someone else's questionaire. the data for X the brouse is in bbase. Data looks like: X X the topic X the maximum answer X answer X . X . X . X X *) X X X const X low = 'a'; X clicks = 86400; (* number of seconds in a day *) X field = 3; X zero = 0; X marker = 15; X X var X who: string; X index: char; X ch: char; X max: char; X i: integer; X j: integer; X time: integer; X rec: usertype; X X begin X writeln(output, 'Whose questionare do you want to brouse?'); X write(output, '? '); X readstring(who); X X X X if Search(who, rec) then begin X X i := ONE; X j := ONE; X reset(bbase,'.date/bbase'); X writeln(output); X write(output, 'Name: '); X writeln(output, rec.login); X write(output, 'Used the Date-A-Base '); X write(output, rec.timeson: field); X if rec.timeson = ONE then X writeln(output, ' time. ') X else X writeln(output, ' times. '); X X write(output, 'Last used the Date-A-Base: '); X time := wallclock - rec.laston; X time := time div clicks; X if time = zero then X writeln(output, 'today.'); X if time = ONE then X writeln(output, 'yesterday.'); X if time > ONE then begin X write(output, time: field); X writeln(output, ' days ago.') X end; X X writeln(output); X while not eof(bbase) do begin X while not eoln(bbase) do begin X read(bbase, ch); X write(output, ch) X end; X readln(bbase); X readln(bbase, max); X for index := low to max do begin X if index = rec.answers[i] then begin X while not eoln(bbase) do begin X read(bbase, ch); X write(output, ch) X end; X writeln(output); X readln(bbase) X end else X readln(bbase) X end; X if j = marker then begin X repeat X writeln(output); X writeln(output, 'Continue? ') X until yesNo; X j := zero; X writeln(output) X end; X j := j + ONE; X i := i + ONE X end (* while not eof *) X end else X writeln(output, 'Sorry that person is not registered!'); X X repeat X writeln(output); X writeln(output, 'Return to the menu? ') X until yesNo X end; { brouse } X X procedure delete; X X (* delete a person from the linked list *) X X var X found: boolean; X pointer: userp; X X begin X found := false; X writeln(output, 'Are you sure you want to delete yourself?'); X if yesNo then begin X pointer := head; X if pointer^.login = static.login then begin X head := pointer^.next; X dispose(pointer) X end else X while not found do X while pointer^.next <> nil do X if pointer^.next^.login = static.login then begin X pointer^.next := pointer^.next^.next; X dispose(pointer^.next); X found := true X end else X pointer := pointer^.next X end X end; { delete } X X X X X X procedure match; X X (* find a match between 2 people. scans the whole linked list X and reports all matches greater than the amount entered. *) X X X const X loginfield = 47; X perfield = 5; X dplaces = 0; X namefield = 33; X low = 9; X high = 100; X X X var X pointer: userp; X percent: integer; X per: real; X found: boolean; X X X begin X pointer := head; X writeln(output); X writeln(output, 'What is the lowest percent match that'); X writeln(output, 'you want to see? '); X repeat X write(output, ' (10 - 99) '); X X readint(percent) X until (percent > low) and (percent < high); X X X writeln(output); X write(output, '%': perfield); X writeln(output, 'name': namefield); X writeln(output, '----------------------------------------------------'); X X found := false; X if pointer <> nil then X while pointer <> nil do begin X per := cstrings(static.answers, pointer^.answers); X if (per >= percent) and (static.sex <> pointer^.sex) then begin X found := true; X writeln(output); X write(output, per: perfield: dplaces); X write(output, '%'); X writeln(output, pointer^.login: loginfield) X end; X pointer := pointer^.next X end; X if not found then begin X writeln(output); X writeln(output, 'Sorry, no matches found today. Try again later.') X end; X repeat X writeln(output); X writeln(output); X writeln(output, 'Are you ready to continue?') X until yesNo X X end; { match } X X procedure bye; X X begin X writeln(output); X writeln(output, 'Thank you for using the Date-A-Base'); X writeln(output, 'Hope to hear from you again soon.'); X writeln(output); X writeln(output); X writeln(output); X writeln(output); X writeln(output); X writeln(output,'(c) 1987 Thomas M. Johnson'); X writeln(output) X end; { bye } X X X procedure menu; X X (* The procedure menu is the programs main menu. It prints the X commands and executes the proper subroutine based on the users X choice. *) X X X const X X lastchoice = 'e'; X var X choice: char; X X begin X repeat X writeln(output); X writeln(output); X writeln(output, ' Menu'); X writeln(output, ' ----'); X writeln(output); X writeln(output, ' [a] answer questionare'); X writeln(output, ' [b] brouse questionare'); X writeln(output, ' [c] make a match'); X writeln(output, ' [d] delete your questionare'); X writeln(output); X writeln(output, ' [e] quit'); X X choice := getanswer(lastchoice); X X case choice of X 'a': X answer; X 'b': X brouse; X 'c': X match; X 'd': X delete; X 'e': X writeln(output) X end X until choice = lastchoice X X end; { menu } X Xbegin X initialize; X if continue then begin X menu; X savedata X end; X bye Xend. { date } X END_OF_date.v2.p if test 15266 -ne `wc -c <date.v2.p`; then echo shar: \"date.v2.p\" unpacked with wrong size! fi # end of overwriting check fi if test -f getw.c -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"getw.c\" else echo shar: Extracting \"getw.c\" $83 characters$ sed "s/^X//" >getw.c <<'END_OF_getw.c' Xextern getwh(); X Xchar * Xgetwh() { Xchar *getlogin(); X return (getlogin()); X } X END_OF_getw.c if test 83 -ne `wc -c <getw.c`; then echo shar: \"getw.c\" unpacked with wrong size! fi # end of overwriting check fi if test -f getw.h -a "${1}" != "-c" ; then echo shar: Will not over-write existing file \"getw.h\" else echo shar: Extracting \"getw.h\" $42 characters$ sed "s/^X//" >getw.h <<'END_OF_getw.h' Xprocedure getwh(var w: string); external; END_OF_getw.h if test 42 -ne `wc -c <getw.h`; then echo shar: \"getw.h\" unpacked with wrong size! fi # end of overwriting check fi echo shar: End of shell archive. exit 0